home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Demos / stklos-demo.stklos < prev    next >
Encoding:
Text File  |  1996-07-21  |  2.0 KB  |  53 lines
  1. #!/usr/local/bin/stk -f
  2. ;;;;
  3. ;;;; s t k l o s - d e m o . s t k       --  A demo which use some STklos classes
  4. ;;;;
  5. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  6. ;;;; 
  7. ;;;; Permission to use, copy, and/or distribute this software and its
  8. ;;;; documentation for any purpose and without fee is hereby granted, provided
  9. ;;;; that both the above copyright notice and this permission notice appear in
  10. ;;;; all copies and derived works.  Fees for distribution or use of this
  11. ;;;; software or derived works may only be charged with express written
  12. ;;;; permission of the copyright holder.  
  13. ;;;; This software is provided ``as is'' without express or implied warranty.
  14. ;;;;
  15. ;;;;           Author: Erick Gallesio [eg@unice.fr]
  16. ;;;;    Creation date: 24-Aug-1993 19:55
  17. ;;;; Last file update: 21-Jul-1996 11:32
  18.  
  19. (require "Tk-classes")
  20.  
  21. ;;;; Utilities
  22.  
  23. (define (make-rectangle coords tags)
  24.   (make <Rectangle> :parent c :coords coords :fill "Ivory4" :tags tags))
  25.  
  26. (define (make-circle coords tags)
  27.   (make <Oval> :parent c :coords coords :fill "Ivory4" :tags tags))
  28.  
  29. ;;;; Make canvas
  30. (define f (make <Frame>))
  31. (define l (make <Label>  :parent f :text "A simple demo written in STklos"))
  32. (define c (make <Canvas> :parent f :relief "groove" :height 400 :width 700))
  33. (define m (make <Label>  :parent f :font "fixed"
  34.              :foreground "red"
  35.                  :text "Left button to move squares. Right button to move circles"))
  36. (define q (make <Button> :text "Quit" :command '(exit)))
  37.  
  38. (pack l c m q :in f :expand #t :fill 'both)
  39. (pack f)
  40.  
  41. ;;;; Make items
  42. (define r1 (make-rectangle '(0 0 50 50)     "Rect"))
  43. (define r2 (make-rectangle '(100 100 150 150)   "Rect"))
  44. (define r3 (make-rectangle '(200 200 250 250)   "Rect"))
  45.  
  46. (define c1 (make-circle '(50 50 100 100)   "Circle"))
  47. (define c2 (make-circle '(150 150 200 200) "Circle"))
  48. (define c3 (make-circle '(250 250 300 300) "Circle"))
  49.  
  50. ;;;; Make rectangles movable with button 1 and circles with button 2
  51. (bind-for-dragging c :button 1 :tag "Rect")
  52. (bind-for-dragging c :button 3 :tag "Circle")
  53.